home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / bcomp / rules.scm < prev    next >
Text File  |  1995-10-13  |  7KB  |  254 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3. ; The syntax-rules macro (new in R5RS)
  4.  
  5. ; Example:
  6. ;
  7. ; (define-syntax or
  8. ;   (syntax-rules ()
  9. ;     ((or)          #f)
  10. ;     ((or e)        e)
  11. ;     ((or e1 e ...) (let ((temp e1))
  12. ;               (if temp temp (or e ...))))))
  13.  
  14.  
  15. (define-usual-macro 'syntax-rules 1
  16.   (lambda (r c subkeywords . rules)
  17.     ;; Pair of the procedure and list of auxiliary names
  18.     `(,(r 'cons)
  19.       ,(process-rules rules subkeywords r c)
  20.       (,(r 'quote) ,(find-free-names-in-syntax-rules subkeywords rules))))
  21.   '(append and car cdr cond cons else eq? equal? lambda let let* map
  22.        pair? quote values))
  23.  
  24.  
  25. (define (process-rules rules subkeywords r c)
  26.  
  27.   (define %append (r 'append))
  28.   (define %and (r 'and))
  29.   (define %car (r 'car))
  30.   (define %cdr (r 'cdr))
  31.   (define %compare (r 'compare))
  32.   (define %cond (r 'cond))
  33.   (define %cons (r 'cons))
  34.   (define %else (r 'else))
  35.   (define %eq? (r 'eq?))
  36.   (define %equal? (r 'equal?))
  37.   (define %input (r 'input))
  38.   (define %lambda (r 'lambda))
  39.   (define %let (r 'let))
  40.   (define %let* (r 'let*))
  41.   (define %map (r 'map))
  42.   (define %pair? (r 'pair?))
  43.   (define %quote (r 'quote))
  44.   (define %rename (r 'rename))
  45.   (define %tail (r 'tail))
  46.   (define %temp (r 'temp))
  47.  
  48.   (define (make-transformer rules)
  49.     `(,%lambda (,%input ,%rename ,%compare)
  50.        (,%let ((,%tail (,%cdr ,%input)))
  51.      (,%cond ,@(map process-rule rules)
  52.          (,%else ,%input)))))       ;Error when left unchanged.
  53.  
  54.   (define (process-rule rule)
  55.     (if (and (pair? rule)
  56.          (pair? (cdr rule))
  57.          (null? (cddr rule)))
  58.     (let ((pattern (cdar rule))
  59.           (template (cadr rule)))
  60.       `((,%and ,@(process-match %tail pattern))
  61.         (,%let* ,(process-pattern pattern
  62.                       %tail
  63.                       (lambda (x) x))
  64.             ,(process-template template
  65.                        0
  66.                        (meta-variables pattern 0 '())))))
  67.     (syntax-error "ill-formed syntax rule" rule)))
  68.  
  69.   ; Generate code to test whether input expression matches pattern
  70.  
  71.   (define (process-match input pattern)
  72.     (cond ((name? pattern)
  73.        (if (member pattern subkeywords)
  74.            `((,%compare ,input (,%rename ',pattern)))
  75.            `()))
  76.       ((segment-pattern? pattern)
  77.        (process-segment-match input (car pattern)))
  78.       ((pair? pattern)
  79.        `((,%let ((,%temp ,input))
  80.            (,%and (,%pair? ,%temp)
  81.             ,@(process-match `(,%car ,%temp) (car pattern))
  82.             ,@(process-match `(,%cdr ,%temp) (cdr pattern))))))
  83.       ((or (null? pattern) (boolean? pattern) (char? pattern))
  84.        `((,%eq? ,input ',pattern)))
  85.       (else
  86.        `((,%equal? ,input ',pattern)))))
  87.  
  88.   (define (process-segment-match input pattern)
  89.     (let ((conjuncts (process-match '(car l) pattern)))
  90.       (if (null? conjuncts)
  91.       `((list? ,input))            ;+++
  92.       `((let loop ((l ,input))
  93.           (or (null? l)
  94.           (and (pair? l)
  95.                ,@conjuncts
  96.                (loop (cdr l)))))))))
  97.  
  98.   ; Generate code to take apart the input expression
  99.   ; This is pretty bad, but it seems to work (can't say why).
  100.  
  101.   (define (process-pattern pattern path mapit)
  102.     (cond ((name? pattern)
  103.        (if (memq pattern subkeywords)
  104.            '()
  105.            (list (list pattern (mapit path)))))
  106.       ((segment-pattern? pattern)
  107.        (process-pattern (car pattern)
  108.                 %temp
  109.                 (lambda (x)    ;temp is free in x
  110.                   (mapit (if (eq? %temp x)
  111.                      path ;+++
  112.                      `(,%map (,%lambda (,%temp) ,x)
  113.                          ,path))))))
  114.       ((pair? pattern)
  115.        (append (process-pattern (car pattern) `(,%car ,path) mapit)
  116.            (process-pattern (cdr pattern) `(,%cdr ,path) mapit)))
  117.       (else '())))
  118.  
  119.   ; Generate code to compose the output expression according to template
  120.  
  121.   (define (process-template template dim env)
  122.     (cond ((name? template)
  123.        (let ((probe (assq template env)))
  124.          (if probe
  125.          (if (<= (cdr probe) dim)
  126.              template
  127.              (syntax-error "template dimension error (too few ...'s?)"
  128.                    template))
  129.          `(,%rename ',template))))
  130.       ((segment-template? template)
  131.        (let ((vars
  132.           (free-meta-variables (car template) (+ dim 1) env '())))
  133.          (if (null? vars)
  134.          (syntax-error "too many ...'s" template)
  135.          (let* ((x (process-template (car template)
  136.                          (+ dim 1)
  137.                          env))
  138.             (gen (if (equal? (list x) vars)
  139.                  x    ;+++
  140.                  `(,%map (,%lambda ,vars ,x)
  141.                      ,@vars))))
  142.            (if (null? (cddr template))
  143.                gen        ;+++
  144.                `(,%append ,gen ,(process-template (cddr template)
  145.                               dim env)))))))
  146.       ((pair? template)
  147.        `(,%cons ,(process-template (car template) dim env)
  148.             ,(process-template (cdr template) dim env)))
  149.       (else `(,%quote ,template))))
  150.  
  151.   ; Return an association list of (var . dim)
  152.  
  153.   (define (meta-variables pattern dim vars)
  154.     (cond ((name? pattern)
  155.        (if (memq pattern subkeywords)
  156.            vars
  157.            (cons (cons pattern dim) vars)))
  158.       ((segment-pattern? pattern)
  159.        (meta-variables (car pattern) (+ dim 1) vars))
  160.       ((pair? pattern)
  161.        (meta-variables (car pattern) dim
  162.                (meta-variables (cdr pattern) dim vars)))
  163.       (else vars)))
  164.  
  165.   ; Return a list of meta-variables of given higher dim
  166.  
  167.   (define (free-meta-variables template dim env free)
  168.     (cond ((name? template)
  169.        (if (and (not (memq template free))
  170.             (let ((probe (assq template env)))
  171.               (and probe (>= (cdr probe) dim))))
  172.            (cons template free)
  173.            free))
  174.       ((segment-template? template)
  175.        (free-meta-variables (car template)
  176.                 dim env
  177.                 (free-meta-variables (cddr template)
  178.                              dim env free)))
  179.       ((pair? template)
  180.        (free-meta-variables (car template)
  181.                 dim env
  182.                 (free-meta-variables (cdr template)
  183.                              dim env free)))
  184.       (else free)))
  185.  
  186.   (make-transformer rules))
  187.  
  188. (define (segment-pattern? pattern)
  189.   (and (segment-template? pattern)
  190.        (or (null? (cddr pattern))
  191.        (syntax-error "segment matching not implemented" pattern))))
  192.  
  193. (define (segment-template? pattern)
  194.   (and (pair? pattern)
  195.        (pair? (cdr pattern))
  196.        (memq (cadr pattern) indicators-for-zero-or-more)))
  197.  
  198. (define indicators-for-zero-or-more (list (string->symbol "...")))
  199.  
  200. ;(define (name? thing)
  201. ;  (or (symbol? thing)
  202. ;      (not (or (pair? thing)            ;Kludge!
  203. ;               (null? thing)
  204. ;               (number? thing)
  205. ;               (boolean? thing)
  206. ;               (char? thing)
  207. ;               (string? thing)))))
  208.  
  209.  
  210.  
  211.  
  212.  
  213.  
  214. ; The following is used by Scheme 48's static linker.
  215.  
  216. (define (find-free-names-in-syntax-rules subkeywords rules)
  217.  
  218.   (define (meta-variables pattern vars)
  219.     (cond ((name? pattern)
  220.        (if (memq pattern subkeywords)
  221.            vars
  222.            (cons pattern vars)))
  223.       ((segment-pattern? pattern)
  224.        (meta-variables (car pattern) ;vars
  225.                (meta-variables (cddr pattern) vars)))
  226.       ((pair? pattern)
  227.        (meta-variables (car pattern)
  228.                (meta-variables (cdr pattern) vars)))
  229.       (else vars)))
  230.  
  231.   (define (free-names template vars names)
  232.     (cond ((name? template)
  233.        (if (or (memq template vars)
  234.            (memq template names))
  235.            names
  236.            (cons template names)))
  237.       ((segment-template? template)
  238.        (free-names (car template)
  239.                vars
  240.                (free-names (cddr template) vars names)))
  241.       ((pair? template)
  242.        (free-names (car template)
  243.                vars
  244.                (free-names (cdr template) vars names)))
  245.       (else names)))
  246.  
  247.   (do ((rules rules (cdr rules))
  248.        (names subkeywords
  249.           (let ((rule (car rules)))
  250.         (free-names (cadr rule)
  251.                 (meta-variables (cdar rule) '())
  252.                 names))))
  253.       ((null? rules) names)))
  254.